#|___________________________________________________________________ 
 | 
 | ViSta - The Visual Statistics System
 | Copyright (c) 1991-2000 by Forrest W. Young
 | For further information contact the author 
 |
 | This file contains container-dependent display window code
 |
 | Much of this code overrides code in display1.lsp and display2.lsp 
 | and it is doubtful that display windows work without containers.
 |___________________________________________________________________ 
 |# 
(setf *help-window-top-most?* t)
(setf *help-window-top-most-default* t)

(defun display-window 
  (text &key (in nil) (fit nil) (title "Text Window") (size '(475 280)) (menu t) 
        (color 'white color-used?) (draw-color 'black) 
        (back-color 'white back-color-used?)
        (location (list (first (floor (/ (- (effective-screen-size) 475) 2))) 60)) 
        (show t) (nowrap nil) (noformat nil) (page nil) (scroll nil) (report nil)
        (container nil)  (top-most *help-window-top-most-default*) (window nil) 
        (pop-out-on-show t)
        (pop-out nil) (free t) (local-menus t))
"Args: TEXT &KEY (in nil) (fit nil) (title \"Text Window\") (size '(475 280)) (location (list (first (floor (/ (- (effective-screen-size) 475) 2))) 60)) (show t) (menu t) (fit nil) (nowrap nil) (noformat nil) (page nil) (top-most nil) (window nil) (pop-out-on-show t))
Displays a window containing TEXT, a required argument, with background color COLOR.  Uses the Original Mac code if  running on a Mac and ignores mswindows options. Uses an existing window object if WINDOW specifies such an object, otherwise a new window is created. 
  For Windows: The new window appears outside of any other window (i.e., on the windows desktop) unless (IN *container-object*) in which case the window appears in the specified container, if POP-OUT-ON-SHOW is NIL. When MENU is T (the default) the window has a menu. The menu is on the container's window bar or, if the window is not in a container, on its own menubar. If not in a container, the window is top-most if TOP-MOST is T (NIL is the default) (ignored if in a container). Window is fit to text when FIT is T. Text is formatted and wrapped unless NOFORMAT or NOWRAP are T. The text is seen pageing as window is constructed if PAGE is T. Currently, (SHOW NIL) only works for (IN NIL) (i.e., windows always show when in a container). Returns window (not container) object and creates two global variables *display-window* and *display-container*."
(let ((w window)
      (mac nil)
      #+macintosh (mac t)
      )
 
  (when (and color-used? back-color-used?) 
        (error "Cannot use both COLOR and BACK-COLOR at the same time."))
  (when color-used? (setf back-color color))
  (when *verbose* (PRINT "DISPLAY-WINDOW"))
  (cond
    #+macintosh
    (mac (setf w (display-window-mac text 
           :title title :size size :location location :show show)))
    (t
     (setf free t)
     (setf local-menus t)
     (cond
       (window
        (setf w window))
       (t
        (cond
          (in
           (setf c in)
           (setf pop-out nil))
          (container 
           (setf c container)
           (setf pop-out nil))
          (t
           (setf c (make-container :title title :type 7 
                                   :show nil :free t :local-menus t))
           (setf pop-out t)))
        (enable-container c)
        (setf w (make-new-display-window-proto2-instance
                 :in in 
                 :title title :size size :location location :show show :scroll scroll
                 :free free :local-menus local-menus :fit fit :top-most top-most
                 :container container :pop-out pop-out :menu menu :color color
                 :nowrap nowrap :noformat noformat :page page :report report
                 ))))
     (send w :draw-color draw-color)
     (send w :back-color back-color)
     (send w :paste-string text)
     ;(send w :show) should it be (send w :show-window show) ?
     (unless menu (send (send w :menu) :remove))
     ;(when show (send c :show)) should it be (when show (send c :show-window)) ?
     (setf *current-text-window* w)))
  w))


(defun make-new-display-window-proto2-instance 
  (&key (in nil) (title "Display Window") (size '(475 280)) (location '(10 20)) 
        (show t) (top-most *help-window-top-most-default*) 
        (color 'white) (menu t) (relocate t)
        (nowrap nil) (noformat nil)  (report nil) (fit nil) (free t) 
        (local-menus t) (container nil) (pop-out t) (page nil) (scroll nil))
"Args &KEY (in nil) (title \"Display Window\") 
(size '(475 280)) (location '(10 20)) (show t) 
(top-most nil) (color 'white) (menu t) (nowrap nil) 
(noformat nil) (fit nil) (page nil) (scroll nil)
Uses display-window-proto2 :isnew method to make a new instance, with container in which it appears controlled by IN or CONTAINER. 
  If (IN *container-object*) then the window appears in the specified container, otherwise; if (CONTAINER *container-object*) then the window appears in the specified container; otherwise it appears on the Windows Desktop. 
  Currently, (SHOW NIL) only works for (IN NIL) (i.e., windows always show when in a container). 
  Note that pop-out, free, and local-menus are also keyword arguments, but the specified values are ignored and always set as follows: We always make (FREE T) and (LOCAL-MENUS T), and if (IN *CONTAINER-OBJECT* ) or (CONTAINERS *CONTAINER-OBJECT*) then (POP-OUT NIL) otherwise (POP-OUT T). When MENU is T, there is a local menu, otherwise there is no menu.  Only popped-out windows can be top-most. Returns window (not container) objid and creates two global variables *display-window* and *display-container*"
  (let ((existing-container *active-container*)
        (w nil)
        (c nil)
    ;    (w-show nil)
        (w-show pop-out);window crashes if nil - fixed - but then other windows dont show
       )
(when *verbose* 
      (format t "~%POP-OUT ~a LOCAL MENUS: ~a MENU ~a ~%"pop-out LOCAL-MENUS menu ))
    (setf free t)
    (setf local-menus t)
    
    (cond 
      (in 
       (setf c in)
       (setf pop-out nil))
      (container 
       (setf c container)
       (setf pop-out nil))
      (t 
       (setf c (make-container :title title :type 7 
                               :show nil :free t :local-menus t))
       (setf pop-out t)
       ))
(when *verbose* 
      (format t "POP-OUT ~A LOCAL MENUS: ~a MENU ~a ~%" POP-OUT LOCAL-MENUS menu)
       )
    (enable-container c)
    (setf w (if report 
                  (send report-window-proto :new
                        :title title :size (- size '(4 4))
                        :location location :show show);was w-show - fwy oct 1 2000
                  (send display-window-proto2 :new :relocate nil
                        :title title :size (- size '(4 4))
                        :location location :show w-show)))
    (when report (send w :initialize w page scroll))
    (if existing-container 
        (enable-container existing-container)
        (disable-container))
    
    (send w :add-slot 'start-time)
    (defmeth w :start-time (&optional (real nil set))
      (if set (setf (slot-value 'start-time) real))
      (slot-value 'start-time))
    (send w :add-slot 'container)
    (defmeth w :container (&optional (objid nil set))
      (if set (setf (slot-value 'container) objid))
      (slot-value 'container))
    (send w :use-color t)
    (send w :container c)
    (when (and (send w :showing) show) ;really, this should be show
          (send w :pop-out pop-out)
          (send w :top-most top-most))
    (defmeth w :do-click (x y m1 m2)
      (if m2 
          (send (send w :menu) :popup x y w)
          (when (send *vista* :click-to-close)(send w :close))))
    (when *verbose* 
          (format t "~%POP-OUT ~A LOCAL MENUS: ~a MENU ~a ~%" POP-OUT LOCAL-MENUS menu)
          )
    (send w :pop-out? pop-out)
    (send w :top-most? top-most)
    (setf *help-window-top-most?* top-most)
    (send w :fit? fit)
    (send w :menu? menu)
    (send w :nowrap nowrap)
    (send w :noformat noformat)
    (setf *display-window* w)
    (setf *display-container* w)
(when *verbose* (format nil "EXITING make-new-display-window-proto2-instance~%"))
    (when (and pop-out show)
          (send w :pop-out pop-out))
;(break)
    w))

(defmeth display-window-proto2 :pop-out (arg)
  (call-next-method arg)
  )

(defmeth display-window-proto2 :pop-out-on-show (&optional (logical nil set))
  (if set (setf (slot-value 'pop-out-on-show) logical))
  (slot-value 'pop-out-on-show))

(defmeth display-window-proto2 :show-window (&key (relocate t))
  (call-next-method)
  (show-display-window self :show nil :menu t 
                       :pop-out (send self :pop-out-on-show) 
                       :relocate relocate :fit nil))

(defmeth display-window-proto2 :show-display-window (&key (relocate nil))
  (show-display-window self :show nil :menu t 
                       :pop-out (send self :pop-out-on-show) 
                       :relocate relocate :fit nil))

(defun show-display-window 
 (w &key (show t) (pop-out t setp) (top-most nil sett) 
    (menu t setm) (fit nil setf) (relocate t))
  (when *verbose* (format t " ~%SHOW-DISPLAY-WINDOW. TOP-MOST ~d~%" top-most))
  (when 
   (send w :showing)
   (defmeth w :redraw () (send self :redraw-it))
   (defmeth w :resize () (send self :resize-it))
   (defmeth w :reformat () (send self :reformat-it))
(when *verbose* 
(print (list "showing FIT MENU TOP_MOST POP_OUT" (send w :showing) fit menu top-most pop-out))
)
   (cond
     (relocate
      (unless (send w :true-location) 
              (send w :true-location 
                    (list (floor (/ (- (first (effective-screen-size)) 475) 2)) 60))))
     (t
      (send w :true-location (send w :location))))   ;fwy 20010401 - added this clause
                                                     ;so window wont move when shouldnt 
   (apply #'send w :location (send w :true-location));and reversed the order of this
   (when fit (send w :fit-window-to-text))           ;and this statement so that fit
   )                                                 ;is reletive to location
  (when pop-out (send w :pop-out t) (send w :pop-out? t))
  (if menu
      (send (send w :menu) :install)
      (send (send w :menu) :remove))
  (send w :top-most t)
  (unless top-most (send w :top-most nil))
  (when *verbose* (PRINT "  EXITING SHOW-DISPLAY-WINDOW"))
  w)


(defun fit-window-to-text ()
        (send *current-text-window* :fit-window-to-text))
    

;fwy 09112000 divided fit-window-to-text into two methods, this and next one
(defmeth display-window-proto2 :fit-window-to-text ()
  (when t ;(send *vista* :fit-window-to-text?)
  (let* ((nlines (send self :nlines))
         (line-height (send self :line-height))
         (window-height (if (send *vista* :fit-window-to-text?) ;fwyfwyfwy
                            (send self :get-height-to-fit-window-to-text)
                            (second (send self :size))))
         )
    (when (> nlines 0)
          (send self :size (first (send self :size)) window-height)
          (if (> (* nlines line-height) window-height)
              (send self :has-v-scroll (* (1+ nlines) line-height))
              (send self :has-v-scroll nil))
          (send self :start-buffering)
          (send self :redraw)
          (send self :buffer-to-screen)
          (send self :size)))))

;fwy 09112000 added unless clause to next method
(defmeth display-window-proto2 :get-height-to-fit-window-to-text ()
(cond 
  ((send *vista* :fit-window-to-text?) ;fwyfwyfwy
   (unless (send self :true-location) 
           (send self  :true-location 
                 (list (floor (/ (- (first (effective-screen-size)) 475) 2)) 60)))
   (let* ((nlines (send self :nlines))
          (line-height (send self :line-height))
          (locy (second (send self :true-location)))
          (window-height 
           (max (+ line-height 2
                   (min (* (1+ nlines) line-height)
                        (- (if (send self :pop-out?)
                               (- (second (effective-screen-size)) locy)
                               (- (second (send (send self :container) :size)) locy))
                           40)))
                (send self :default-window-height))))  
     window-height))
  (t (second (send self :size)))))

(defmeth display-window-proto2 :location (&optional (x nil setx) (y nil sety))
  (cond
    (setx (unless sety (error "You must specify both x and y"))
          (call-next-method x y))
    (t
     (call-next-method))))

(defmeth display-window-proto2 :true-location (&optional (list nil set))
  (when set (setf (slot-value 'true-location)
                  (if (> (max (- list (effective-screen-size))) 0)
                      (list 100 50)
                      list)))
  (slot-value 'true-location))
    

(defmeth display-window-proto2 :close ()
  (call-next-method)
  (setf *display-window* nil)
  (setf *display-container* nil))

#|___________________________________________
 |
 | VISTA SYSTEM HELP METHODS
 |___________________________________________
 |#


(defmeth vista-system-object-proto :datasheet-help ()
  (file-to-window (strcat *help-dir-name* "datashee.hlp") "DataSheet" *help-window*))

(defmeth vista-system-object-proto :desktop-help ()
  (file-to-window (strcat *help-dir-name* "desktop.hlp") "DeskTop" *help-window*))

(defmeth vista-system-object-proto :file-to-help-window
            (filename title w &optional (flush t) (add-help t) (show t))
  (with-open-file 
   (g filename)
   (unless w 
           (setf w (initial-help-window))
           (send *vista* :set-help-variables w T))
   (file-to-window filename title w  nil add-help)
   (send self :update-help-window w g title flush add-help show);added show
   (setf *current-help-window* w)
   (setf *current-text-window* w)
   t))

(defmeth vista-system-object-proto :get-window (w)
  (if (and w (send w :used?) (not (send *vista* :reuse-help-windows)))
      (setf w (initial-help-window))) 
  w)

(defmeth vista-system-object-proto :update-help-window 
                          (w g title &optional (flush t) (add-help t) (show t))
  (when flush (send w :flush-window))
  (send w :scroll 0 0)
  (if (or (not add-help) 
          (equal title "Bug List") 
          (equal title "About These Data"))
      (send w :title title)
      (send w :title (strcat "Help: " title)))
  (if g
      (send w :paste-stream g)
      (send w :paste-string (send *current-data* :about)))
  (if (> (send w :y) (second (send w :size))) 
       (send w :has-v-scroll (send w :y))
       (send w :has-v-scroll nil))
  (when show
        #+macintosh (when (not (equal (front-window) self)) (send w :show-window))
        #-macintosh (send w :show-window))
  t)

(defmeth vista-system-object-proto :set-help-variables (w state)
  (when *verbose* (PRINT "  SET-HELP-VARIABLES"))
  (send *vista* :help-window-object w)
  (send *vista* :help-window-status state)
  (setf *current-help-window* w)
  (setf *current-text-window* w)
  (setf *help-window* w)
  (defmeth w :remove ()
    (send self :bottom-most t)
    (send self :true-location (send self :location))
    (send self :location (first (send self :location)) 2000)
    )
  )


(defun read-help (helpfilename &optional (title "Help") (window-object))
"ARGS: HELPFILE &OPTIONAL (TITLE \"Help\") WINDOW-OBJECT
Reads help from HELPFILE, in the help directory. Displays help in WINDOW-OBJECT (defaults to default help window) with TITLE."
  (file-to-window (strcat *help-dir-name* helpfilename)
                  title
                  (if window-object window-object
                      (send *vista* :help-window-object)) t nil))


(defmeth vista-system-object-proto :create-message-window 
  (&key (title "Text Window") (size '(300 100)) (container *desktop-container*) 
        (top-most t) (pop-out nil) (location) (color 'post-it-yellow)
        (show t) (menu nil))
  (unless location
          (when size (setf location (floor (/ (- (effective-screen-size) size) 2)))))
  (enable-container container)
  (let ((w (send display-window-proto2 :new :title title
                 :location location  :show t :size size
                 :nowrap nil :noformat nil :menu menu
            )))
    (send w :use-color t)
    (send w :back-color color)
    (send w :add-slot 'container container)
    (send w :pop-out pop-out)
    (send w :top-most top-most)
    (unless menu (send (send w :menu) :remove))
    w))



#|___________________________________________
 |
 | HELP WINDOW
 |
 | (help "string") is the basic function, 
 | but it has to be in file defun2.lsp
 | It uses (help-window "string") which 
 | appears in display4.lsp
 |___________________________________________
 |#


(defun datasheet-help ()
  (send *vista* :datasheet-help))

(defun desktop-help ()
  (send *vista* :desktop-help))

(defun desktop-help-window ()
"Args: None"
  (help-window))

(setf workmap-help
      (send menu-item-proto :new "Show Help" :key #\H
            :action 'show-help))

(defun show-help ()
  (send *workmap* :show-help *workmap*))

(defun file-to-window 
	(filename title window &optional (flush t) (add-help t) (fit t) (show t))
"Args: filename title window &optional (flush t) (add-help t) (fit t) (show t)
Depending on value of global variable *linked-window*, constructs a help or chain window (not reports) from text in a file. All text must come from a file via this function for the help and chained windows systems to work right."
    (when *file-verbose* (format t "; reading ~a~%" filename))
  (let ((w
         (cond 
           (*linked-window* 
            (setf *linked-window* nil)
            (file-to-chain-window  filename title window flush add-help fit show))
           (t
            (file-to-single-window filename title window flush add-help fit show)))))
    (send w :add-slot 'file filename)
    (defmeth w :file (&optional (name nil set))
      (if set (setf (slot-value 'file) name))
      (slot-value 'file))
    w))
    
   

(defun text-to-file (text &optional file)
  (set-working-directory *default-path*)
  (when (not file) 
        (setf file 
              #-X11       (set-file-dialog  "Save Text In File:" "txt")
              #+X11       (file-save-dialog "Save Text In File:" "*.txt" ".")
              ))
  (when file 
        (setf file (string-downcase-if-not-X11 file))
        (let ((f (open (string file) :direction :output))
              (num-strings (length text))
              (oldbreak *breakenable*))
          (setq *breakenable* nil)
          (unwind-protect 
           (dotimes (i num-strings)
                    (format f "~a" (select text i)))
           )
          (setq *breakenable* oldbreak)
          (close f)
          (format t "; finished saving ~s~%" file)
          file)))

(defun file-to-single-window 
  (filename title window &optional (flush t) (add-help t) (fit t) (show t))
"args: filename title window &optional (flush t) (add-help t) (fit t) (show t)
gets text from filename and displays in *help-window* unless WINDOW is specified. Same args as file-to-chain-window"
  (let* ((w (if window window *help-window*))
         (old-w w)
         (height))
    (when (not w)
          (setf w (initial-help-window))
          (setf old-w w))
    (setf w (send *vista* :get-window w))
    (send w :start-buffering)
    (with-open-file 
     (g filename)
     (send *vista* :set-help-variables w t) ;fwy 20010401 changed last argument in next line
     (send *vista* :update-help-window w g title flush add-help nil));from show to nil
    (send *vista* :help-window-status t)    ;to get (not relocate) to work right
    (setf *current-help-window* w)
    (setf *current-text-window* w)
    (send w :set-window-parameters fit show)
    w))


(defmeth display-window-proto2 :set-window-parameters (fit show)
  (let* ((height)
         )
    (if fit (setf height (send self :get-height-to-fit-window-to-text))
        (setf height (second (send self :size))))
    (when (and  show (> (send self  :nlines) 0)) 
          (send self :size (first (send self :size)) height)
          (send self :show-window :relocate nil))
    (send self :top-most *help-window-top-most?*)
    (send self :top-most? *help-window-top-most?*)
    (send self :buffer-to-screen)
    (send self :scroll 0 0)
    (send self :used? t)
    self))


(defun show-plot-help ()
(when *verbose* (PRINT "  SHOW-PLOT-HELP"))
  (show-display-window *help-window* :pop-out t 
                       :top-most (send *help-window* :top-most)
                       :menu t :fit t))


(defun paste-plot-help (plot-help &optional ignored)
  (let ((w (send *vista* :help-window-object)))
    (send w :paste-string plot-help)
    w))

(defun show-plot-help ()
  (let ((w (send *vista* :help-window-object)))
    #+macintosh (when (not (equal (front-window) w)) (send w :show-window))
    #-macintosh (send w :show-window)
    (if (> (* (+ 2 (send w :nlines)) (send w :line-height))
           (second (send w :size)))
       (send w :has-v-scroll (* (+ 2 (send w :nlines)) 
                                (send w :line-height)))
       (send w :has-v-scroll nil))
    (send *vista* :help-window-status t)
    (setf *current-help-window* w)
    (setf *current-text-window* w)
    w))
#+macintosh(defmeth display-window-proto :fit-window-to-text () )

(defun initial-about-window ()
  (let* ((w (initial-display-window)))
    (setf *about-window* w)
    w))

(defun initial-message-window ()
  (let* ((w (initial-display-window 300 100)))
    (setf *message-window* w)
    w))


(defun initial-help-window ()
  (let* ((w (initial-display-window 475 300 :location '(3000 3000) 
             :color 'post-it-yellow)))
    (send *vista* :set-help-variables w T)
    (setf *help-window* w)
   ; (setf *deskop-help-window* w)
    (send w :top-most (send w :top-most? ))
    w))

(defun initial-display-window 
  (&optional (width 475) (height 300) 
             &key (location (list (floor (/ (- (first (effective-screen-size)) 475) 2)) 60))
             (color 'white))
  (let* ((c (container :show nil));fwy******
         (w (display-window 
            " " 
            :color color
            :location location
            :size (list width height) ;  :in c ;nil
            :show nil :menu t :pop-out t  :fit nil)))
    (send (send w :menu) :remove)
    w))



;------------------------
;message-window
;------------------------

(defun vista-message (&optional text &key new (title "ViSta Message") (beep t) (fit t) (flush t)
                          (pop-out nil) (top-most t) (menu nil) (color 'post-it-yellow)
                           (size '(300 100)) location frame-location (show-time 5))
"Args: text &key new (title \"ViSta Message\") (beep t) (pop-out nil) (top-most t) (fit t) (flush t) size location
Displays TEXT in window of SIZE at LOCATION with TITLE. Beeps. Message goes to globally defined *message-window*, unless NEW is T in which case a new window is defined. Window is top-most by default." 
(when *verbose* (PRINT "HELP-WINDOW"))
  (let* ((w *help-window*)
         )
    (cond 
      (new (setf w (initial-message-window)))
      (w
       (when (not (send *vista* :reuse-help-windows))
             (setf w (initial-message-window)))
       (when flush (send w :flush-window))
       (send w :top-most top-most)
       (send w :back-color color)
       )
      (t (setf w (initial-message-window))))
    (send w :pop-out  pop-out)
    (send w :top-most top-most)
    (unless pop-out
            (unless text (setf text ""))
            ;(setf text (strcat text (format nil "~2%Click to Close.~%")))
            (defmeth w :do-click (x y m1 m2)
              (send w :idle-on nil)
              (send w :close))
            (send w :idle-on t)
            )
    (send w :scroll 0 0)
    (when frame-location (apply #'send w :frame-location frame-location))
    (when text (send w :show-message text title beep))
    (send (send w :menu) :remove)
    (when fit (send w :fit-window-to-text))
    w))

